home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / xlib.lha / xlib / cdecl / extern.scm < prev    next >
Text File  |  1990-06-05  |  8KB  |  227 lines
  1. ;;; C declaration compiler.
  2.  
  3. ;*              Copyright 1989 Digital Equipment Corporation
  4. ;*                         All Rights Reserved
  5. ;*
  6. ;* Permission to use, copy, and modify this software and its documentation is
  7. ;* hereby granted only under the following terms and conditions.  Both the
  8. ;* above copyright notice and this permission notice must appear in all copies
  9. ;* of the software, derivative works or modified versions, and any portions
  10. ;* thereof, and both notices must appear in supporting documentation.
  11. ;*
  12. ;* Users of this software agree to the terms and conditions set forth herein,
  13. ;* and hereby grant back to Digital a non-exclusive, unrestricted, royalty-free
  14. ;* right and license under any changes, enhancements or extensions made to the
  15. ;* core functions of the software, including but not limited to those affording
  16. ;* compatibility with other hardware or software environments, but excluding
  17. ;* applications which incorporate this software.  Users further agree to use
  18. ;* their best efforts to return to Digital any such changes, enhancements or
  19. ;* extensions that they make and inform Digital of noteworthy uses of this
  20. ;* software.  Correspondence should be provided to Digital at:
  21. ;* 
  22. ;*                       Director of Licensing
  23. ;*                       Western Research Laboratory
  24. ;*                       Digital Equipment Corporation
  25. ;*                       100 Hamilton Avenue
  26. ;*                       Palo Alto, California  94301  
  27. ;* 
  28. ;* This software may be distributed (but not offered for sale or transferred
  29. ;* for compensation) to third parties, provided such third parties agree to
  30. ;* abide by the terms and conditions of this notice.  
  31. ;* 
  32. ;* THE SOFTWARE IS PROVIDED "AS IS" AND DIGITAL EQUIPMENT CORP. DISCLAIMS ALL
  33. ;* WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING ALL IMPLIED WARRANTIES OF
  34. ;* MERCHANTABILITY AND FITNESS.   IN NO EVENT SHALL DIGITAL EQUIPMENT
  35. ;* CORPORATION BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL
  36. ;* DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR
  37. ;* PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS
  38. ;* ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS
  39. ;* SOFTWARE.
  40.  
  41. ;;; This module compiles "extern" forms which define C library procedures.
  42. ;;;
  43. ;;;    <extern> ::= ( EXTERN <type> <fname> [ <arg> ... ] )
  44. ;;;
  45. ;;;    <fname>  ::= a Scheme string
  46. ;;;
  47. ;;;    <arg>     ::= ( <type> <id> )
  48. ;;;             ( IN <type> <id> )
  49. ;;;             ( OUT <type> <id> )
  50. ;;;             ( IN_OUT <type> <id> )
  51. ;;;
  52. ;;;    <id>     ::= a Scheme symbol
  53.  
  54. (module extern)
  55.  
  56. ;;; The following function syntax checks an extern expression.  It will either
  57. ;;; report an error, or return the expression as its value.
  58.  
  59. (define (INPUT-EXTERN exp)
  60.     (if (and (>= (length exp) 3)
  61.          (parse-type (cadr exp))
  62.          (string? (caddr exp)))
  63.     (begin (for-each parse-arg (cdddr exp))
  64.            exp)
  65.     (error "Illegal EXTERN syntax: ~s" exp)))
  66.  
  67. ;;; Parses the argument list and calls error on an error.
  68.  
  69. (define (PARSE-ARG exp)
  70.     (if (and (pair? exp)
  71.          (or (and (= (length exp) 2)
  72.               (parse-type (car exp))
  73.               (symbol? (cadr exp)))
  74.          (and (= (length exp) 3)
  75.               (memq (car exp) '(in out in_out))
  76.               (parse-type (cadr exp))
  77.               (symbol? (caddr exp)))))
  78.     #t
  79.     (error "Illegal ARGUMENT syntax: ~s" exp)))
  80.  
  81. ;;; Code is generated by the following function.
  82.  
  83. (define (EMIT-EXTERNS externs extern-file-root type-file-root)
  84.     (let ((module (uis extern-file-root)))
  85.      (with-output-to-file
  86.          (string-append extern-file-root ".t")
  87.          (lambda ()
  88.              (write `(herald ,module (env tsys (xlib interface))))
  89.              (newline)
  90. ;             (write `(include ,(string-append type-file-root ".sch")))
  91.              (newline)
  92.              (for-each (lambda (x) (emit-extern x 'define)) externs)))))
  93.  
  94.  
  95. ;;; The definition for the interface procedure for an extern is created by
  96. ;;; the following procedure.
  97.  
  98. (define (EMIT-EXTERN extern defform)
  99.     (let ((xname (uis (caddr extern) "*"))
  100.       (rettype (cadr extern))
  101.       (args (cdddr extern)))
  102.      
  103.      (define (EMIT-CALL)
  104.          `(,xname ,@(map (lambda (x) (car (last-pair x))) args)))
  105.      
  106.      (define (FORMALS args)
  107.          (if args
  108.              (if (eq? (caar args) 'out)
  109.              (formals (cdr args))
  110.              (cons (car (last-pair (car args)))
  111.                    (formals (cdr args))))
  112.              '()))
  113.      
  114.      (pp `(define-foreign ,xname
  115.           (,(caddr extern) ,@(map simple-type-arg args))
  116.           ,(simple-type-return rettype)
  117.           ))
  118.      (newline)
  119.      (pp `(,defform (,(uis (caddr extern)) ,@(formals args))
  120.            (let* (,@(map arg-in args)
  121.               (return-value
  122.               ,(cond ((eq? rettype 'void)
  123.                   `(block ,(emit-call) '#f))
  124.                  ((eq? rettype 'string)
  125.                   `(asciz->string ,(emit-call)))
  126.                  ((isa-pointer? rettype)
  127.                   `(cons ',(base-type rettype)
  128.                      ,(emit-call)))
  129.                  (else (emit-call)))))
  130.              ,(let ((out (args-out args)))
  131.                (if out
  132.                    (if (eq? rettype 'void)
  133.                    (if (= (length out) 1)
  134.                        (car out)
  135.                        `(return ,@out))
  136.                    `(return return-value ,@out))
  137.                    'return-value)))))
  138.      (newline)))
  139.  
  140. ;;; Called to do input conversion for arguments.  Return an expression
  141. ;;; of th form (<var> <value>).
  142.  
  143. (define (ARG-IN arg)
  144.     (let* ((flag (if (memq (car arg) '(in out in_out))
  145.              (car arg)
  146.              #f))
  147.        (type (if flag (cadr arg) (car arg)))
  148.        (var  (if flag (caddr arg) (cadr arg))))
  149.       (case flag
  150.         ((out) `(,var (make-bytev ,(if (eq? type 'string)
  151.                            4
  152.                            (size-of type)))))
  153.         (else (cond ((eq? type 'string)
  154.                  `(,var (if (string? ,var)
  155.                     (string->asciz! ,var)
  156.                     (error
  157.                            "Argument is incorrect type: ~s"
  158.                         ,var))))
  159.                 ((isa-pointer? type)
  160.                  `(,var (,(uis "CHK-" (base-type type)) ,var)))
  161.                 (else  `(,var ,var)))))))
  162.  
  163. ;;; Return a list of the expressions required to do output conversion after
  164. ;;; an external call.
  165.      
  166. (define (ARGS-OUT args)
  167.     
  168.     (define (ARG-OUT arg)
  169.         (let* ((flag (if (memq (car arg) '(in out in_out))
  170.                  (car arg)
  171.                  #f))
  172.            (type (if flag (cadr arg) (car arg)))
  173.            (var  (if flag (caddr arg) (cadr arg))))
  174.           (case flag
  175.             ((out)
  176.              (cond ((eq? type 'string)
  177.                 `(string->asciz! (mref-pointer ,var 0))) 
  178.                    ((isa-pointer? type)
  179.                 `(cons ',(base-type type)
  180.                        (mref-pointer ,var 0)))
  181.                    ((or (isa-union? type) (isa-struct? type)
  182.                     (isa-array? type))
  183.                 `(cons ',(pointed-to-by type) ,var))
  184.                    (else `(,(getprop (base-type type) 'to-get)
  185.                        ,var 0))))
  186.             (else #f))))
  187.  
  188.     (if args
  189.     (let ((out (arg-out (car args))))
  190.          (if out
  191.          (cons out (args-out (cdr args)))
  192.          (args-out (cdr args))))
  193.     '()))
  194.  
  195. ;;; Converts the type of a procedure argument to a simple C-type.
  196.  
  197. ;(define returned-pointers 
  198. ;  '(Region charAP XVisualInfoP XImageP XrmString XrmDatabase DisplayP GC
  199. ;       ScreenP VisualP AtomAP XFontStructP charPAP ColormapAP KeySymAP
  200. ;       XModifierKeymapP XHostAdressAP XTimeCoordAP))
  201.  
  202. (define (SIMPLE-TYPE-arg type)
  203.   (let ((type (car type)))
  204.     (cond ((eq? type 'out) '(in rep/extend))
  205.       ((eq? type 'string) '(in rep/string))
  206.       ((isa-pointer? type) '(in rep/c-pointer))
  207.       ((isa-procp? type) '(in rep/extend))
  208.       (else 
  209.        (xcase (base-type type)
  210.          ((char) '(in rep/char))
  211.          ((shortint shortunsigned int unsigned) '(in rep/integer)))))))
  212.  
  213. (define (SIMPLE-TYPE-return type)
  214.     (cond ((eq? type 'void) 'ignore)
  215.       ((eq? type 'string) 'rep/pointer)
  216.       ((isa-pointer? type) 'rep/pointer)
  217.       ((isa-procp? type) 'rep/pointer)
  218.       (else 
  219.        (xcase (base-type type)
  220.          ((char) 'rep/char)
  221.          ((shortint shortunsigned int unsigned) 'rep/integer)))))
  222.  
  223.  
  224.  
  225.                      
  226.                      
  227.